COMMENT ⊗   VALID 00004 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	   SRCTRN 						 -*-LISP-*-
C00004 00003
C00008 00004
C00010 ENDMK
C⊗;
;;;   SRCTRN 						 -*-LISP-*-
;;;   **************************************************************
;;;   ***** MACLISP *****  (Initialization for COMPLR) *************
;;;   **************************************************************
;;;   ** (C) Copyright 1981 Massachusetts Institute of Technology **
;;;   ****** This is a Read-Only file! (All writes reserved) *******
;;;   **************************************************************


(setq SRCTRNVERNO '#.(let* ((file (caddr (truename infile)))
			   (x (readlist (exploden file))))
			  (setq |verno| (cond ((fixp x) file)  ('/4)))))



(EVAL-WHEN (COMPILE) 
     (AND (OR (NOT (GET 'COMPDECLARE 'MACRO))
	      (NOT (GET 'OUTFS 'MACRO)))
	  (LOAD `(,(cond ((status feature ITS) '(DSK COMLAP))
			 ('(LISP)))
		  CDMACS
		  FASL)))
)


(EVAL-WHEN (COMPILE) (COMPDECLARE) (FASLDECLARE) (GENPREFIX |/|st|) )




;;;; SOURCE-TRANS for LISTP, < and >, and bitwise logical operations.


(defun SI:LISTP-FERROR-expander (x &aux (arg (cadr x)))
  (setq x (cond ((eq (car x) 'FERROR) `(CERROR () () ,.(cdr x)))
		((not (eq (car x) 'LISTP)) (barf x SI:LISTP-FERROR-expander))
		((|no-funp/|| (setq arg (macroexpand arg)))
		  `(OR (NULL ,arg) (EQ (TYPEP ,arg) 'LIST)))
		('T (|non-simple-x/|| (car x) arg))))
  (values x 'T))


(defun SI:ML-<>-expander  (form &aux op ex? nargs)
   (cond 
     ((setq op (assq (car form) '((<  . () ) 
				  (>  . () )
				  (>= . <) 
				  (<= . >))))
      (if (or (< (setq nargs (length (cdr form))) 2) (> nargs 510.))
	  (error '|WNA during SOURCE-TRANS expansion| form))
        ;; << is the name of the function -- >> is name of its inversion,
        ;;  if an inversion must be used instead of the name directly.
      (let (((<<  . >>) op)
	    ((a b) (cdr form))
	    c)
	(cond ((= nargs 2)
	         ;; Simple case -- 2 args only
	        (if >> (setq form `(NOT (,>> ,a ,b)) ex? 'T)))	
	      ((and (= nargs 3)
		    (not (|side-effectsp/|| a)) 
		    (not (|side-effectsp/|| b)) 
		    (not (|side-effectsp/|| (setq c (cadddr form)))))
	         ;; Remember |side-effectsp/|| may macroexpand. "between-p",
	        (let* ((bb (if (+INTERNAL-DUP-P b) b (si:gen-local-var)))
		       (body `(AND (,<< ,a ,bb) (,<< ,bb ,c))))
		     ;; Maybe a 'lambda' wrapper?
		   (if (not (eq bb b)) 
		       (setq body `((LAMBDA (,bb) ,body) ,b)))
		   (setq form body ex? 'T)))
	      ('T ;; Must bind all args, even though each one appears only 
		     ;; once; otherwise its code will not get run when a>b.  
		     ;;  "a" must be EVAL'd first!
	       (let ((arglist (cdr form)) ga gb letlist body)
		    (si:gen-local-var ga)
		    (setq letlist `((,ga ,(car arglist))))
		    (mapc #'(lambda (ll) 
			      (si:gen-local-var gb)
			      (push `(,gb ,ll) letlist)
			      (push (cond (>> `(NOT (,>> ,ga ,gb)))
					  ('T `(,<< ,ga ,gb)))
				    body)
			      (setq ga gb))
			  (cdr arglist))
		    (setq form `(LET ,(nreverse letlist)
				     (AND ,.(nreverse body)))
			  ex? 'T)))))))
   (values form ex?))



(defun SI:ML-trans-expander (form &aux (ex? 'T))
   (let ((fun (car form)) 
	 (nargs (length (cdr form)))
	 (oform form)
	 (interval '(1 . 1)) 
	 op)
     (cond ((eq fun 'LOGNOT) 
	    (setq form `(BOOLE 10. ,(cadr form) -1)))
	   ((setq op (cdr (assq fun '((LOGAND . 1) 
				      (LOGIOR . 7) 
				      (LOGXOR . 6)))))
	    (setq interval '(2 . 510.)
		  form `(BOOLE ,op ,.(cdr form))))
	   ((setq op (cdr (assq fun '((FIXNUMP . (EQ (TYPEP X) 'FIXNUM))
				      (FLONUMP . (FLOATP X))
				      (EVENP . (NOT (ODDP X)))))))
	    (setq form (subst (cadr form) 'X op)))
	   ('T (setq ex? () )))
     (and ex? 
	  (or (< nargs (car interval)) (> nargs (cdr interval)))
	  (error '|WNA during SOURCE-TRANS expansion| oform)))
   (values form ex?))


(mapc 
  #'(lambda (y) 
      (let (((fun . l) y) z)
	(mapc #'(lambda (x)
		  (or (memq fun (setq z (get x 'SOURCE-TRANS)))
		      (putprop x (cons fun z) 'SOURCE-TRANS))
		  (or (getl x '(SUBR LSUBR))
		      (equal (get x 'AUTOLOAD) '((lisp) MLSUB))
		      (putprop x '((lisp) MLSUB) 'AUTOLOAD)))
	      l)))
  '((SI:ML-trans-expander LOGAND LOGIOR LOGXOR LOGNOT FIXNUMP FLONUMP EVENP)
    (SI:ML-<>-expander < > <= >= )
    (SI:LISTP-FERROR-expander LISTP FERROR)))

β